Sub AddForeignKey()
Dim cat1 As ADOX.Catalog
Dim key1 As ADOX.Key
Dim col1 As ADOX.Column

'Specify database engine, data source, and table to index
Set cat1 = New ADOX.Catalog
cat1.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
     & "Data Source=C:\LunarSociety\OLS1.mdb"

'Check for preexisting foreign key.
'If it exists, document it, then delete it.
For Each key1 In cat1.Tables("MEM-RES").Keys
    With key1
        If .Name = "MemberIDFK" Then
            Debug.Print .Name
            Debug.Print String(4, " ") & "Key Type = " & _
                 KeyType(.Type)
            Debug.Print String(4, " ") & "Related Table = " & _
                 .RelatedTable
            For Each col1 In _
                 cat1.Tables("MEM-RES").Keys(.Name).Columns
                 Debug.Print String(4, " ") & "Key column name = " _
                     & col1.Name
            Next col1
            Debug.Print String(4, " ") & "Update Type = " & _
                 RuleType(.UpdateRule)
            Debug.Print String(4, " ") & "Delete Type = " & _
                 RuleType(.DeleteRule)
            cat1.Tables("MEM-RES").Keys.Delete .Name
        End If
    End With
Next key1

'Create new foreign key. Permit cascading updates.
Set key1 = New ADOX.Key
With key1
     .Name = "MemberIDFK"
     .Type = adKeyForeign
     .RelatedTable = "MEMBERS"
     .Columns.Append "MemberID"
     .Columns("MemberID").RelatedColumn = "MemberID"
     .UpdateRule = adRICascade
End With
cat1.Tables("MEM-RES").Keys.Append key1

'Clean up before exiting
Set key1 = Nothing
Set cat1 = Nothing
                   
End Sub

Function KeyType(intType As Integer) As String
     Select Case intType
          Case adKeyPrimary
               KeyType = "adKeyPrimary"
          Case adKeyForeign
               KeyType = "adKeyForeign"
          Case adKeyUnique
               KeyType = "adKeyUnique"
          Case Else
               KeyType = CStr(intType)
     End Select
End Function

Function RuleType(intType As Integer) As String
     Select Case intType
          Case adRINone
               RuleType = "adRINone"
          Case adRICascade
               RuleType = "adRICascade"
          Case adRISetNull
               RuleType = "adRISetNull"
          Case adRISetDefault
               RuleType = "adRISetDefault"
          Case Else
               RuleType = CStr(intType)
    End Select
End Function
